home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / lzsfx.com / OPEN.PRC < prev   
Encoding:
Text File  |  1988-08-08  |  1.7 KB  |  69 lines
  1. (*   FROM DEFS.INC IMPORT anystr, pathtype, tex.
  2.    Cant(fname:pathtype) ;
  3.    ShortName(name : pathtype) :integer ;
  4.    ExtPos(name) : integer ;
  5.    NewFname( old, ext : pathtype ; mode : char ('+-')) : pathtype ;
  6.    FileExist(name: pathtype): Boolean;
  7. *)
  8. procedure Cant(fname : pathtype) ;
  9.   begin
  10.     WriteLn('Cannot open file [', fname, '].') ;
  11.   end ; {Cant}
  12.  
  13. procedure CantHalt(fname: pathtype);
  14.   begin
  15.     Cant(fname); Halt(1)
  16.   end {CantHalt};
  17.  
  18. function ShortName(name : pathtype) :integer ;
  19.   var i,p : integer ;
  20.   begin
  21.     i := 1 ;  p := 0 ;
  22.     while i <= length(name) do begin
  23.       case name[i] of
  24.         ':','\' : p := i ;                      { rev. 88/4/28 }
  25.         #$81..#$9f,#$E0..#$FC : i := i + 1 ;
  26.       end ;
  27.       i := i + 1
  28.     end ;
  29.     ShortName := p + 1
  30.   end ; {ShortName}
  31.  
  32. function ExtPos( name : pathtype) : integer ;
  33.   var i,p : integer ;
  34.   begin
  35.     i := 1 ;  p := 0 ;
  36.     while i <= length(name) do begin
  37.       case name[i] of
  38.         '.' : p := i ;
  39.         '\' : p := 0 ;
  40.         #$81..#$9f,#$E0..#$FC : i := i + 1 ;
  41.       end ;
  42.       i := i + 1
  43.     end ;
  44.     ExtPos := p
  45.   end ; {ExtPos}
  46.  
  47. function NewFname( old, ext : pathtype ; mode : char) : pathtype ;
  48.   var p : integer ;
  49.   begin
  50.     p := ExtPos(old);
  51.     case mode of
  52.       '+' :
  53.         if p = 0 then NewFname := old + '.' + ext
  54.                  else NewFname := old ;
  55.       '-' :
  56.         if p = 0 then NewFname := old + '.' + ext
  57.                  else NewFname := Copy(old,1,p) + ext ;
  58.     end ;
  59.   end ; {NewFname}
  60.  
  61. function FileExist(name:pathtype):Boolean;
  62.   var f:file;
  63.   begin  Assign(f,name);
  64. {$i-} Reset(f); {$i+}
  65.     if IOresult = 0 then begin
  66.       Close(f); FileExist := true
  67.     end
  68.     else FileExist := false
  69.   end ;